home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / analyze.lisp next >
Lisp/Scheme  |  1992-09-10  |  44KB  |  1,310 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; This is pass 1 of the compiler. Return an analyzed tree.
  4. (defun analyze (form &optional (*dynamic-control-points* nil))
  5.   (let* ((*env* (make-lex-env :outermost-form form))
  6.      (*analysis-errors* 0)
  7.      (*node-id* -1)
  8.      (original-control-points *dynamic-control-points*)
  9.      (tree (analyze-1 form t argc-var-name)))
  10.     (cond ((> *analysis-errors* 0) nil)
  11.       ((equal original-control-points
  12.           *dynamic-control-points*)
  13.        tree)
  14.       ;; Keep analyzing until all block and tag xfers are correct!
  15.       (t (analyze form *dynamic-control-points*)))))
  16.  
  17. ;;; When tail? is true we can *immediately* return form's value.
  18. (defun analyze-1 (form tail? mv-holder &optional parent-cons)
  19.   (if (code-p form)
  20.       form
  21.       (if (config-lisp-line-numbers? *config*)
  22.       (let ((line (source-line (or parent-cons form))))
  23.         (if (null line)
  24.         (analyze-2 form tail? mv-holder)
  25.         (let ((*current-line* line)
  26.               (real-form (if (line-symbol-p form)
  27.                      (line-symbol-symbol form)
  28.                      form)))
  29.           (analyze-2 real-form tail? mv-holder))))
  30.       (analyze-2 form tail? mv-holder))))
  31.  
  32. (defun analyze-2 (form tail? mv-holder)
  33.   (let* ((exp-form (macroexpand-fully form *compiler-macro-env*))
  34.      (tree (analyze-dispatch exp-form tail? mv-holder)))
  35.     (unless (null tree)
  36.       (setf (code-tail? tree) tail?)
  37.       (setf (code-mv-holder tree) mv-holder)
  38.       ;; Move the tmp var increment into the analyzers?
  39.       (when (typep tree '(or proc function-call if scope-seq))
  40.     (update-tmp-var-count 1)))
  41.     tree))
  42.  
  43. (defun analyze-dispatch (form tail? mv-holder)
  44.   (if (atom form)
  45.       (analyze-atom form tail? mv-holder)
  46.       (case (first form)
  47.     (if (analyze-if form tail? mv-holder))
  48.     (progn (analyze-progn form tail? mv-holder))
  49.     (block (analyze-block form tail? mv-holder))
  50.     (catch (analyze-catch form mv-holder))
  51.     (quote (analyze-quote form))
  52.     (setq (analyze-setq form tail? mv-holder))
  53.     (return-from (analyze-return-from form))
  54.     (throw (analyze-throw form))
  55.     (tagbody (analyze-tagbody form))
  56.     ((flet labels)
  57.      (analyze-local-function-def form tail? mv-holder))
  58.     (macrolet (analyze-macrolet form tail? mv-holder))
  59.     (symbol-macrolet (analyze-symbol-macrolet form tail? mv-holder))
  60.     ((funcall apply)
  61.      (analyze-funcall/apply form tail? mv-holder))
  62.     (go (analyze-go form))
  63.     ((named-function named-macro-function)
  64.      (analyze-named-function form))
  65.     (spec-bind (analyze-spec-bind form mv-holder))
  66.     (function (analyze-function form tail?))
  67.     (unwind-protect
  68.          (analyze-unwind-protect form mv-holder))
  69.     (mv-bind (analyze-mv-bind form tail? mv-holder))
  70.     (multiple-value-call
  71.         (analyze-multiple-value-call form tail? mv-holder))
  72.     (values (analyze-values form))
  73.     (the (analyze-the form tail? mv-holder))
  74.     (eval-when (analyze-eval-when form tail? mv-holder))
  75.     (c-code (analyze-c-code form tail? mv-holder))
  76.     (c-struct-ref (analyze-c-struct-ref form tail? mv-holder))
  77.     (c-struct-def (analyze-c-struct-def form tail? mv-holder))
  78.     (switch (analyze-switch form tail? mv-holder))
  79.     (t (analyze-function-call form tail? mv-holder)))))
  80.  
  81. (defun macroexpand-fully (form menv)
  82.   (multiple-value-bind (mexp more?)
  83.       ;; Must call compiler-macros first!!!
  84.       (macroexpand-w (compiler-macroexpand-w form menv) menv)
  85.     (if (and more? (not (eq form mexp)))
  86.     (macroexpand-fully mexp menv)
  87.     mexp)))
  88.  
  89. (defun update-tmp-var-count (n)
  90.   (unless (null (current-proc))
  91.     (incf (proc-max-tmp-var-count (current-proc)) n)))
  92.  
  93. (defun analyze-c-code (form tail? mv-holder)
  94.   (declare (ignore tail? mv-holder))
  95.   (make-c-code :string (second form)))
  96.  
  97. (defun analyze-c-struct-ref (form tail? mv-holder)
  98.   (declare (ignore tail? mv-holder))
  99.   (destructuring-bind (ignore struct name field) form
  100.     (declare (ignore ignore))
  101.     (let ((info (lookup-named-c-type name)))
  102.       (make-c-struct-ref :name 'c-struct-ref
  103.              :field (lookup-c-struct-field info field)
  104.              :struct-info info
  105.              :args (list (analyze-1 struct nil nil))))))
  106.  
  107. (defun analyze-c-struct-def (form tail? mv-holder)
  108.   (declare (ignore tail? mv-holder))
  109.   (destructuring-bind (ignore struct name field value) form
  110.     (declare (ignore ignore))
  111.     (let ((info (lookup-named-c-type name)))
  112.       (make-c-struct-def :name 'c-struct-def
  113.              :field (lookup-c-struct-field info field)
  114.              :struct-info (lookup-named-c-type name)
  115.              :args (list (analyze-1 struct nil nil)
  116.                      (analyze-1 value nil nil))))))
  117.  
  118. (defun analyze-eval-when (form tail? mv-holder)
  119.   (destructuring-bind (ignore when . body) form
  120.     (declare (ignore ignore))
  121.     (when (member 'compile when)
  122.       (eval `(progn ,@body)))
  123.     (analyze-1 (if (member 'load when)
  124.            `(progn ,@body)
  125.            nil)
  126.            tail?
  127.            mv-holder)))
  128.  
  129. (defun analyze-quote (form)
  130.   (destructuring-bind (ignore data) form
  131.     (declare (ignore ignore))
  132.     (analyze-constant data)))
  133.  
  134. (defun analyze-constant (k)
  135.   (make-constant :data k
  136.          :out-type (or (type-macroexpand (type-of k)) t)))
  137.  
  138. (defun analyze-atom (atom tail? mv-holder)
  139.   (if (or (keywordp atom)
  140.       (eq atom 't)
  141.       (eq  atom 'nil)    ; specially handled by the linker -STILL???
  142.       (and (not (symbolp atom)) (constantp atom)))
  143.       (analyze-constant atom)
  144.       (let ((special? (special-var-p atom)))
  145.      (case special?
  146.       (:constant (let ((expr (constant-expr atom)))
  147.                (if (and (config-misc-speed-hacks? *config*)
  148.                 (constant-expression? expr))
  149.                (analyze-constant (constant-expression-value expr))
  150.                (analyze-special-ref atom tail? mv-holder))))
  151.       (:special (analyze-special-ref atom tail? mv-holder))
  152.       (t (multiple-value-bind (var through-proc?)
  153.          (lookup-variable atom)
  154.            (if (null var)
  155.            (progn (compiler-warn "Reference to undefined variable ~A"
  156.                      atom)
  157.               (analyze-special-ref atom tail? mv-holder))
  158.            (new-var-ref var through-proc?))))))))
  159.  
  160. (defun constant-expression? (x)
  161.   (or (numberp x)
  162.       (stringp x)
  163.       (and (symbolp x) (boundp x) (eq x (symbol-value x)))
  164.       (quoted-constant? x)))
  165.  
  166. (defun quoted-constant? (x)
  167.   (and (listp x) (eq (first x) 'quote)))
  168.  
  169. (defun constant-expression-value (x)
  170.   (if (quoted-constant? x)
  171.       (second x)
  172.       x))
  173.  
  174. (defun analyze-special-ref (sym tail? mv-holder)
  175.   (let ((info (get-variable-info sym)))
  176.     (analyze-1 (if (null info)
  177.            `(symbol-value ',sym)
  178.            `(the ,(variable-info-type info) (symbol-value ',sym)))
  179.            tail? mv-holder)))
  180.  
  181. (defun analyze-special-def (sym value tail? mv-holder)
  182.   (let ((info (get-variable-info sym)))
  183.     (analyze-1 (if (null info)
  184.            `(set ',sym ,value)
  185.            `(the ,(variable-info-type info) (set ',sym ,value)))
  186.            tail? mv-holder)))
  187.  
  188. (defun analyze-setq (form tail? mv-holder)
  189.   (if (null (cdr form))
  190.       (analyze-1 'nil tail? mv-holder)
  191.       (destructuring-bind (ignore atom value . rest) form
  192.     (declare (ignore ignore))
  193.     (if (null rest)
  194.         (let ((special? (special-var-p atom)))
  195.           (case special?
  196.         (:special (analyze-special-def atom value tail? mv-holder))
  197.         (:constant (compiler-warn "Attempt to change constant ~A"
  198.                       atom))
  199.         (t (multiple-value-bind (var through-proc?)
  200.                (lookup-variable atom)
  201.              (if (null var)
  202.              (progn
  203.                (compiler-warn "Assignment to undefined variable ~A"
  204.                       atom)
  205.                (analyze-special-def atom value tail? mv-holder))
  206.              (progn (incf (var-num-defs var))
  207.                 (update-var-extent var through-proc?)
  208.                 (let ((value (analyze-1 value nil nil))
  209.                       (type (var-definite-type var)))
  210.                   (setf (code-out-type value) type)
  211.                   (make-var-def
  212.                    :var var
  213.                    :out-type type
  214.                    :innermost-proc (current-proc)
  215.                    :value value))))))))
  216.         (analyze-1 `(progn (setq ,atom ,value) (setq ,@rest))
  217.                tail?
  218.                mv-holder)))))
  219.  
  220. (defun analyze-if (form tail? mv-holder)
  221.   (destructuring-bind (ignore test then . else) form
  222.     (declare (ignore ignore))
  223.     (unless (null (cdr else))
  224.       (compiler-warn "Extra forms in IF: ~A" form))
  225.     (let ((then-tree (analyze-1 then tail? mv-holder (cddr form)))
  226.       (else-tree (analyze-1 (car else) tail? mv-holder else)))
  227.       (if (and (config-misc-speed-hacks? *config*)
  228.            (listp test)
  229.            (member (first test) '(not null) :test #'eq))
  230.       (make-if :test (analyze-1 (second test) nil nil (cdr form))
  231.            :then else-tree
  232.            :else then-tree)
  233.       (make-if :test (analyze-1 test nil nil (cdr form))
  234.            :then then-tree
  235.            :else else-tree)))))
  236.  
  237. (defun analyze-switch (form tail? mv-holder)
  238.   (destructuring-bind (ignore test . cases) form
  239.     (declare (ignore ignore))
  240.     (multiple-value-bind (specific-cases default)
  241.     (let ((rev (reverse cases)))
  242.       (if (eq (caar rev) t)
  243.           (values (reverse (cdr rev)) `(progn ,@(cdar rev)))
  244.           (values cases nil)))
  245.       (loop for (key . consequent) in specific-cases
  246.         collect (if (listp key) key (list key)) into keys
  247.         collect (analyze-1 `(progn ,@consequent) tail? mv-holder)
  248.         into consequents
  249.         finally (return (make-switch
  250.                  :test (analyze-1 test nil nil)
  251.                  :keys keys
  252.                  :consequents consequents
  253.                  :default (analyze-1 default tail? mv-holder)))))))
  254.  
  255. (defun dynamic-transfer-method? (node-id)
  256.   (member node-id *dynamic-control-points*))
  257.  
  258. (defun add-reanalysis-info (control-point)
  259.   (push (control-point-id control-point) *dynamic-control-points*))
  260.  
  261. (defun analyze-block (form tail? mv-holder)
  262.   (let ((node-id (incf *node-id*)))
  263.     (destructuring-bind (ignore name . body) form
  264.       (declare (ignore ignore))
  265.       (if (null body)
  266.       (analyze-1 'nil nil mv-holder)
  267.       (if (dynamic-transfer-method? node-id)
  268.           (analyze-dynamic-block name body mv-holder)
  269.           (analyze-static-block node-id name body tail? mv-holder))))))
  270.  
  271. (defun analyze-static-block (node-id name body tail? mv-holder)
  272.   (let ((point (make-static-scope-control-point
  273.         :name name
  274.         :id node-id
  275.         :c-name (lisp->c-block-name name (new-name-id))
  276.         :tail? tail?
  277.         :mv-holder mv-holder)))
  278.     (letf ((lex-env-blocks *env*) (cons point (lex-env-blocks *env*)))
  279.       (letf ((lex-env-tags *env*) (cons point (lex-env-tags *env*)))
  280.     (let ((body (loop for x in body
  281.               for pos from (length body) downto 1
  282.               collect (analyze-1 x
  283.                          (and (= pos 1) tail?)
  284.                          (and (= pos 1)
  285.                           mv-holder)))))
  286.       (if (null (scope-control-point-refs point))
  287.           (make-progn-if-needed body)
  288.           (progn (when (static-scope-control-point-convert? point)
  289.                (add-reanalysis-info point))
  290.              (setf (scope-control-point-parent point)
  291.                (make-scope-seq
  292.                 :control-point point
  293.                 :body body)))))))))
  294.  
  295. (defun analyze-dynamic-block (name body mv-holder)
  296.   (let ((point (make-dynamic-block-control-point
  297.         :name name
  298.         :tag-name (unique-control-point-tag name)
  299.         ;;  RETURN-FROM needs this tmp mv holder
  300.         :receive-var (genstring "dynamicblock_mv_holder"))))
  301.     (analyze-dynamic-scope body mv-holder point)))
  302.  
  303. (defun analyze-catch (form mv-holder)
  304.   (destructuring-bind (ignore name . body) form
  305.     (declare (ignore ignore))
  306.     (let ((point (make-catch-control-point
  307.           :name name
  308.           :tag-name (analyze-1 name nil nil))))
  309.       (analyze-dynamic-scope body mv-holder point))))
  310.             
  311. (defun analyze-dynamic-scope (body mv-holder point)
  312.   (if (null body)
  313.       (analyze-1 'nil nil nil)
  314.       (letf ((lex-env-blocks *env*) (cons point (lex-env-blocks *env*)))
  315.     (letf ((lex-env-tags *env*) (cons point (lex-env-tags *env*)))
  316.       (make-scope-seq
  317.        :control-point point
  318.        :body (loop for x in body
  319.                for pos from (length body) downto 1
  320.                collect (analyze-1 x
  321.                       nil
  322.                       (and (= pos 1) mv-holder))))))))
  323.  
  324. (defun analyze-return-from (form)
  325.   (destructuring-bind (ignore block &optional value) form
  326.     (declare (ignore ignore))
  327.     (multiple-value-bind (dest through-proc? unwind-count thru-cps)
  328.     (lookup-block block)
  329.       (if (null dest)
  330.       (compiler-warn "Reference to undefined block ~A" block)
  331.       (let ((ct (make-scope-control-transfer
  332.              :destination-point dest
  333.              :unwind-count unwind-count)))
  334.         (push ct (scope-control-point-refs dest))
  335.         (etypecase dest
  336.           (dynamic-block-control-point
  337.            (setf (scope-control-transfer-send-value ct)
  338.              (analyze-1 value
  339.                 nil
  340.                 (scope-control-point-receive-var dest))))
  341.           (static-scope-control-point
  342.            (when (or through-proc?
  343.              (> unwind-count 0)
  344.              (some #'dynamic-control-point-p thru-cps))
  345.          (setf (static-scope-control-point-convert? dest) t))
  346.            (setf (scope-control-transfer-send-value ct)
  347.              (analyze-1 value
  348.                 (code-tail? dest)
  349.                 (code-mv-holder dest)))))
  350.         ct)))))
  351.  
  352. (defun analyze-throw (form)
  353.   (destructuring-bind (ignore tag value) form
  354.     (declare (ignore ignore))
  355.     (let ((throw-mv-holder (genstring "throw_mv_holder")))
  356.       (make-scope-control-transfer
  357.        ;; dummy control point
  358.        :destination-point (make-dynamic-scope-control-point
  359.                :name tag
  360.                :tag-name (analyze-1 tag nil nil)
  361.                :receive-var throw-mv-holder)
  362.        :send-value (analyze-1 value nil throw-mv-holder)))))
  363.  
  364. (defun analyze-tagbody (form)
  365.   (destructuring-bind (ignore . body) form
  366.     (declare (ignore ignore))
  367.     (if (null body)
  368.     (analyze-1 'nil nil nil)
  369.     (loop for x being the elements of body
  370.           when (symbolp x)
  371.           collect
  372.           (let ((node-id (incf *node-id*)))
  373.         (if (dynamic-transfer-method? node-id)
  374.             (make-dynamic-tag-control-point
  375.              :name x
  376.              :c-name (lisp->c-tag-name x (new-name-id))
  377.              :tag-name (unique-control-point-tag x))
  378.             (make-static-tag-control-point
  379.              :name x
  380.              :id node-id
  381.              :c-name (lisp->c-tag-name x (new-name-id)))))
  382.           into control-points and
  383.           when (member x tags) 
  384.           do (compiler-warn "Duplicate tag ~A seen in tagbody" x)
  385.           collect x into tags 
  386.           finally
  387.           (return
  388.         (letf ((lex-env-tags *env*)
  389.                (append control-points (lex-env-tags *env*)))
  390.           (letf ((lex-env-blocks *env*)
  391.              (append control-points (lex-env-blocks *env*)))
  392.             (let ((body (loop with head = control-points
  393.                       for x being the elements of body
  394.                       collect (if (symbolp x)
  395.                           (pop head)
  396.                           (analyze-1 x nil nil)))))
  397.               (loop for p in control-points
  398.                 when (and (static-tag-control-point-p p)
  399.                       (static-tag-control-point-convert? p))
  400.                 do (add-reanalysis-info p))
  401.               (make-tag-seq
  402.                :control-points control-points
  403.                :body body)))))))))
  404.  
  405. (defun analyze-go (form)
  406.   (destructuring-bind (ignore tag) form
  407.     (declare (ignore ignore))
  408.     (multiple-value-bind (dest through-proc? unwind-count thru-cps)
  409.     (lookup-tag tag)
  410.       (if (null dest)
  411.       (compiler-warn "Reference to undefined tag ~A" tag)
  412.       (progn
  413.         (when (and (static-tag-control-point-p dest)
  414.                (or through-proc?
  415.                (> unwind-count 0)
  416.                (some #'dynamic-control-point-p thru-cps)))
  417.           (setf (static-tag-control-point-convert? dest) t))
  418.         (make-tag-control-transfer :destination-point dest
  419.                        :unwind-count unwind-count))))))
  420.           
  421. (defun analyze-function (form tail?)
  422.   (destructuring-bind (ignore function) form
  423.     (declare (ignore ignore))
  424.     (typecase function
  425.       (symbol (multiple-value-bind (var through-proc?)
  426.           (lookup-function function)
  427.         (if (null var)
  428.             (analyze-1 `(symbol-function ',function) tail? nil)
  429.             (new-var-ref var through-proc?))))
  430.       (lambda-expr (analyze-proc (local-proc-name) function nil))
  431.       (t (compiler-warn "~A is not a legal function" function)))))
  432.  
  433. ;;; HEY! shouldn't really intern stuff here
  434. (defun local-proc-name (&optional (name (genstring "anon")))
  435.   (intern (concatenate 'string
  436.                (apply #'concatenate
  437.                   'string
  438.                   (mapcar #'(lambda (x)
  439.                       (symbol-name (proc-name x)))
  440.                       *proc-chain*))
  441.                "-"
  442.                (genstring name))))
  443.  
  444. (defun analyze-named-function (form)
  445.   (destructuring-bind (special-form name lambda-expr) form
  446.     (analyze-proc name
  447.           lambda-expr
  448.           (eq special-form 'named-macro-function))))
  449.  
  450. (defun analyze-spec-bind (form mv-holder)
  451.   (destructuring-bind (i1 specs . body) form
  452.     (declare (ignore i1))
  453.     (let ((vars (loop for s in specs collect (lookup-variable s))))
  454.       (make-spec-bind-seq
  455.        :specials vars
  456.        :values (loop for var in vars collect (new-var-ref var nil))
  457.        :body (letf ((lex-env-blocks *env*)
  458.             (cons :UW-SPEC-BIND (lex-env-blocks *env*)))
  459.            (letf ((lex-env-tags *env*)
  460.               (cons :UW-SPEC-BIND (lex-env-tags *env*)))
  461.          (analyze-1 `(progn ,@body) nil mv-holder)))))))
  462.  
  463. (defun spec-bind-body (body vars)
  464.   (let ((specials (collect-specials vars)))
  465.     (if (null specials)
  466.     `(progn ,@body)
  467.     `(spec-bind ,(mapcar #'var-name specials)
  468.       ,@body))))
  469.  
  470. (defun analyze-proc (name lambda-expr macro-function?)
  471.   (destructuring-bind (i1 lambda-list . body+decls) lambda-expr
  472.     (declare (ignore i1))
  473.     (multiple-value-bind (body decls)
  474.     (parse-body body+decls)
  475.       (letf ((lex-env-decls *env*) (new-decl-env decls))
  476.     (flet ((initial-proc (creator)
  477.          (funcall creator
  478.               :name name
  479.               :c-name (lisp->c-proc-name name macro-function?)
  480.               :max-tmp-var-count 0
  481.               :vars-to-declare nil
  482.               :volatile ""
  483.               :body nil
  484.               :funarg-refs nil))
  485.            (analyze-args+body (tree)
  486.          ;; Need to push tree into env BEFORE analyzing the lambda-list
  487.          ;; in case the lambda-list contains var refs to outer names.
  488.          (letf  ((lex-env-variables *env*)
  489.              (cons tree (lex-env-variables *env*)))
  490.            (letf ((lex-env-functions *env*)
  491.               (cons tree (lex-env-functions *env*)))
  492.              (letf ((lex-env-blocks *env*)
  493.                 (cons tree (lex-env-blocks *env*)))
  494.                (letf ((lex-env-tags *env*)
  495.                   (cons tree (lex-env-tags *env*)))
  496.              (let* ((*proc-chain* (cons tree
  497.                             *proc-chain*))
  498.                 (*name-id-counter* 0)
  499.                 (var-info (analyze-lambda-list lambda-list))
  500.                 (all-vars (var-info-all-vars var-info))
  501.                 (spec-bind-body (spec-bind-body body
  502.                                 all-vars)))
  503.                (setf (proc-var-info tree) var-info)
  504.                (letf ((lex-env-variables *env*)
  505.                   (append all-vars
  506.                       (cons tree
  507.                         (lex-env-variables *env*))))
  508.                  (loop for var in all-vars do
  509.                    (setf (var-innermost-proc var) tree))
  510.                  (setf (proc-body tree)
  511.                    (analyze-1 `(let* ,(var-info-auxes var-info)
  512.                         ,spec-bind-body)
  513.                           t
  514.                           argc-var-name))
  515.                  tree))))))))
  516.       (if (null *proc-chain*)
  517.           (let ((p (initial-proc #'make-top-level-proc)))
  518.         (setf (top-level-proc-oe-vars p) nil)
  519.         (analyze-args+body p))
  520.           (let ((p (initial-proc #'make-inner-proc)))
  521.         (setf (inner-proc-oe-refs p) nil)
  522.         (setf (inner-proc-parent-chain p) *proc-chain*)
  523.         (analyze-args+body p))))))))
  524.  
  525. (defun analyze-macrolet (form tail? mv-holder)
  526.   (destructuring-bind (ignore defs . body) form
  527.     (declare (ignore ignore))
  528.     (let* ((macros (mapcar
  529.             #'(lambda (unit)
  530.             (destructuring-bind (name lambda-list . body) unit
  531.               (cons name
  532.                 (make-macro
  533.                  :expansion-function
  534.                  (eval (parse-macro-definition name
  535.                                    lambda-list
  536.                                    nil
  537.                                    body))
  538.                  :original-arg-list lambda-list))))
  539.             defs))
  540.        (*compiler-macro-env*
  541.         (make-macro-env
  542.          :macros (append macros (macro-env-macros *compiler-macro-env*))
  543.          :symbol-macros (macro-env-macros *compiler-macro-env*))))
  544.       (analyze-1 `(locally ,@body) tail? mv-holder))))
  545.  
  546. (defun analyze-symbol-macrolet (form tail? mv-holder)
  547.   (destructuring-bind (ignore defs . body) form
  548.       (declare (ignore ignore))
  549.     (let ((*compiler-macro-env*
  550.        (make-macro-env
  551.         :macros (macro-env-macros *compiler-macro-env*)
  552.         :symbol-macros (append defs (macro-env-symbol-macros *env*)))))
  553.       (analyze-1 `(locally ,@body) tail? mv-holder))))
  554.  
  555. (defun analyze-local-function-def (form tail? mv-holder)
  556.   (destructuring-bind (definer defs . main-body+decls) form
  557.     (multiple-value-bind (main-body main-decls)
  558.     (parse-body main-body+decls)
  559.       (let* ((vars (mapcar #'(lambda (d)
  560.                    (new-fvar (first d)))
  561.                defs))
  562.          (functions
  563.           (labels ((analyze-defs ()
  564.              (mapcar #'(lambda (def)
  565.                      (destructuring-bind
  566.                        (name lambda-list . body+decls) def
  567.                        (multiple-value-bind (body decls)
  568.                        (parse-body body+decls)
  569.                      (analyze-1
  570.                       `(named-function
  571.                         ,(local-proc-name
  572.                           (symbol-name name))
  573.                         (lambda ,lambda-list
  574.                           (declare ,@decls)
  575.                           (block ,name ,@body)))
  576.                       nil
  577.                       argc-var-name))))
  578.                  defs)))
  579.         (ecase definer
  580.           (labels
  581.               (letf ((lex-env-functions *env*)
  582.                  (append vars (lex-env-functions *env*)))
  583.             (analyze-defs)))
  584.           (flet (analyze-defs))))))
  585.     (make-named-local
  586.      :letrec? (eq definer 'labels)
  587.      :vars vars
  588.      :values functions
  589.      :body (letf ((lex-env-functions *env*)
  590.               (append vars (lex-env-functions *env*)))
  591.          (letf ((lex-env-decls *env*) (new-decl-env main-decls))
  592.            (analyze-1 `(progn ,@main-body) tail? mv-holder))))))))
  593.  
  594. (defun analyze-unwind-protect (form mv-holder)
  595.   (destructuring-bind (ignore protected-form . cleanup-forms) form
  596.     (declare (ignore ignore))
  597.     (letf ((lex-env-blocks *env*) (cons :UW-PROTECT (lex-env-blocks *env*)))
  598.       (letf ((lex-env-tags *env*) (cons :UW-PROTECT (lex-env-tags *env*)))
  599.     (declare-vars-volatile)
  600.     (make-unwind-protect
  601.      :protected-form (analyze-1 protected-form nil mv-holder)
  602.      :cleanup-form (analyze-1 `(progn ,@cleanup-forms)
  603.                   nil
  604.                   nil))))))
  605.  
  606. ;;; HEY! this is a hack. Fix all this mv stuff to work more rigidly.
  607. (defun analyze-mv-bind (form tail? mv-holder)
  608.   (destructuring-bind (ignore vars values-form . body+decls) form
  609.     (declare (ignore ignore))
  610.     (analyze-multiple-value-call
  611.      `(multiple-value-call #'(lambda ,vars ,@body+decls) ,values-form)
  612.      tail?
  613.      mv-holder)))
  614.  
  615. (defun analyze-multiple-value-call (form tail? mv-holder)
  616.   (destructuring-bind (ignore function . args) form
  617.     (declare (ignore ignore))
  618.     (if (and (anonymous-function-expr? function) ; anonymous func?
  619.          (= (length args) 1))
  620.     (analyze-inline-mv-call function (car args) tail? mv-holder)
  621.     ;; SLOW general case.
  622.     (analyze-1 `(apply ,function ,@(mapcar #'(lambda (a)
  623.                            `(multiple-value-list ,a))
  624.                     args))
  625.            tail?
  626.            mv-holder))))
  627.  
  628. (defun analyze-inline-mv-call (func arg tail? mv-holder)
  629.   (destructuring-bind (i1 (i2 lambda-list . body+decls)) func
  630.     (declare (ignore i1 i2))
  631.     (if (null lambda-list)
  632.     (analyze-1 `((lambda ,lambda-list ,@body+decls)) tail? mv-holder)
  633.     (multiple-value-bind (body decls)
  634.         (parse-body body+decls)
  635.       (letf ((lex-env-decls *env*) (new-decl-env decls))
  636.         (let* ((mv-lambda-list (cons '&optional (remove '&optional
  637.                                 lambda-list)))
  638.            (var-info (analyze-lambda-list mv-lambda-list))
  639.            (new-mv-holder (genstring "mv_holder"))
  640.            (all-vars (var-info-all-vars var-info))
  641.            (spec-bind-body (spec-bind-body body all-vars)))
  642.           (make-inline-mv-call
  643.            :new-holder new-mv-holder
  644.            :var-info var-info
  645.            :body (letf ((lex-env-variables *env*)
  646.                 (append all-vars (lex-env-variables *env*)))
  647.                (analyze-1  `(let* ,(var-info-auxes var-info)
  648.                      ,spec-bind-body)
  649.                    tail?
  650.                    mv-holder))
  651.            :values (list (analyze-1 arg nil new-mv-holder)))))))))
  652.  
  653. (defun analyze-values (form)
  654.   (destructuring-bind (ignore . values) form
  655.     (declare (ignore ignore))
  656.     (make-mvalues :args (mapcar #'(lambda (v)
  657.                     (analyze-1 v nil nil))
  658.                 values))))
  659.  
  660. (defun analyze-progn (form tail? mv-holder)
  661.   (destructuring-bind (ignore . body) form
  662.     (declare (ignore ignore))
  663.     (if (null (cdr body))
  664.     (analyze-1 (first body) tail? mv-holder)
  665.     (make-progn-if-needed
  666.      (loop for x in body
  667.            for pos from (length body) downto 1
  668.            collect (analyze-1 x
  669.                   (and (= pos 1) tail?)
  670.                   (and (= pos 1) mv-holder)))))))
  671.  
  672. (defun analyze-function-call (form tail? mv-holder)
  673.   (destructuring-bind (function . args) form
  674.     (typecase function
  675.       (symbol (analyze-named-function-call function args tail? mv-holder))
  676.       (lambda-expr
  677.        (analyze-inline-function-call function args tail? mv-holder))
  678.       (t (compiler-warn "~A is not a legal function" function)))))
  679.  
  680.  
  681. (defun analyze-named-function-call (function args tail? mv-holder)
  682.   (multiple-value-bind (var through-proc?)
  683.       (lookup-function function)
  684.     (if (null var)            ; must be a global function call
  685.     (let ((function-info (get-proc-info function)))
  686.       (cond ((and (proc-info-p function-info)
  687.               (config-inline-calls? *config*)
  688.               (inline-function? function function-info)
  689.               (proc-info-defined? function-info))
  690.          (analyze-inline-function-call
  691.           (proc-info-lambda-expr function-info)
  692.           args tail? mv-holder))
  693.         ;; HEY! Generalize this sv rewrite hack!!!!
  694.         ((and (null mv-holder)
  695.               (eq function 'floor))
  696.          (analyze-1 `(floor/1v ,@args) tail? mv-holder))
  697.         (t (let* ((arg-trees
  698.                (mapcar #'(lambda (x) (analyze-1 x nil nil))
  699.                    args)))
  700.              (typecase function-info
  701.                (primitive-info
  702.             (make-primitive-call
  703.              :info function-info
  704.              :args arg-trees))
  705.                (foreign-info
  706.             (make-foreign-call
  707.              :name function
  708.              :info function-info
  709.              :args arg-trees))
  710.                (t
  711.             (add-ftype-info
  712.              (make-named-call
  713.               :info function-info
  714.               :emit-as-goto? (maybe-remove-tail-recursion function
  715.                                       tail?)
  716.               :name function
  717.               :args arg-trees))))))))
  718.     (make-unnamed-call
  719.      :spread-args? nil
  720.      :function-form (new-var-ref var through-proc?)
  721.      :args (mapcar #'(lambda (x) (analyze-1 x nil nil))
  722.                args)))))
  723.  
  724. (defun add-ftype-info (call)
  725.   (return-from add-ftype-info call)
  726.   ;; HEY! fix this
  727.   (let ((info (function-call-info call)))
  728.     (if (null info)
  729.     call
  730.     (progn (loop for arg in (function-call-args call)
  731.              for type in (function-info-in-types info)
  732.              do (setf (code-out-type arg)
  733.                   (merge-types (code-out-type arg)
  734.                        type)))
  735.            ;; HEY! make this work for <> 1 value
  736.            (setf (code-out-type call)
  737.              (merge-types (code-out-type call)
  738.                   (first (function-info-out-types info))))
  739.                     ; (print-call-types call)
  740.            call))))
  741.  
  742. (defun print-call-types (call)
  743.   (print (function-call-name call))
  744.   (print (code-out-type call))
  745.   (loop for arg in (function-call-args call)
  746.     do (print (code-out-type arg))))
  747.  
  748. (defun merge-types (one two)
  749.   (cond ((or (null one) (eq one t)) two)
  750.     ((or (null two) (eq two t)) one)
  751.     (t (if (subtypep one two) one two))))
  752.  
  753. (defun merge-out-type (tree type)
  754.   (setf (code-out-type tree)
  755.     (merge-types (code-out-type tree) type)))
  756.  
  757. (defun maybe-remove-tail-recursion (proc-name tail?)
  758.   (let ((proc (current-proc)))
  759.     (if (and tail?
  760.          (config-remove-tail-recursion? *config*)
  761.          (eq proc-name (proc-name proc))
  762.          (not (var-info-hairy? (proc-var-info proc))))
  763.     (progn (setf (proc-start-label proc) (genstring "START"))
  764.            proc)
  765.     nil)))
  766.  
  767. (defun analyze-funcall/apply (form tail? mv-holder)
  768.   (destructuring-bind (type function . args) form
  769.     (if (and (eq type 'funcall)        ; (funcall (function ...) ...)
  770.          (listp function)
  771.          ;; DO NOT optimize (symbol-function 'foo), just (function foo)
  772.          ;; We want some way to force an fcell indirection.
  773.          (eq (first function) 'function))
  774.     (analyze-1 `(,(second function) ,@args)  tail? mv-holder)
  775.     (make-unnamed-call
  776.      :spread-args? (if (eq type 'apply) t nil)
  777.      :function-form (analyze-1 function nil nil)
  778.      :args (mapcar #'(lambda (x) (analyze-1 x nil nil)) args)))))
  779.  
  780. (defun analyze-inline-function-call (function args tail? mv-holder)
  781.   (destructuring-bind (ignore lambda-list . body+decls) function
  782.     (declare (ignore ignore))
  783.     (if (hairy-lambda-list? lambda-list)
  784.     (analyze-hairy-inline-function-call
  785.      function lambda-list body+decls args tail? mv-holder)
  786.     (analyze-simple-inline-function-call
  787.      lambda-list body+decls args tail? mv-holder))))
  788.  
  789. (defun analyze-simple-inline-function-call (lambda-list
  790.                         body+decls args tail? mv-holder)
  791.   (multiple-value-bind (body decls)
  792.       (parse-body body+decls)
  793.     (letf ((lex-env-decls *env*) (new-decl-env decls))
  794.       (let* ((values (mapcar #'(lambda (arg) (analyze-1 arg nil nil))
  795.                  args))
  796.          (vars (mapcar #'(lambda (var val)
  797.                    (declare (ignore val))
  798.                    (let ((v (new-var var t)))
  799.                  ;; Propagate type info
  800.                  ;; HEY! This is wrong if v is assigned to!
  801.                  ;; Need to do this in later stages.
  802.                  ;(setf (var-definite-type v)
  803.                  ;      (merge-types
  804.                  ;    (code-out-type val)
  805.                  ;    (var-definite-type v)))
  806.                  v))
  807.                lambda-list
  808.                values))
  809.          (body (letf ((lex-env-variables *env*)
  810.               (append vars (lex-env-variables *env*)))
  811.              (analyze-1 (spec-bind-body body vars)
  812.                 tail?
  813.                 mv-holder))))
  814.     (if (null args)
  815.         (make-progn-if-needed body)
  816.         (make-named-local
  817.          :letrec? nil
  818.          :vars vars
  819.          :values values
  820.          :body body))))))
  821.  
  822. ;;; Perform runtime hairy-function call work at compile time when possible.
  823. (defun analyze-hairy-inline-function-call (function lambda-list
  824.                             body+decls args
  825.                             tail? mv-holder)
  826.   (let* ((info (analyze-lambda-list lambda-list :inline-function))
  827.      (all-var-names (mapcar #'var-name (var-info-all-vars info))))
  828.     (multiple-value-bind (fixed-args sequential-inits)
  829.     (hairy->fixed-arg-list info args all-var-names)
  830.       (if (listp fixed-args)
  831.       (multiple-value-bind (body decls)
  832.           (parse-body body+decls)
  833.         (analyze-1 `((lambda ,all-var-names
  834.                (let* ,(var-info-auxes info)
  835.                  (declare ,@decls)
  836.                  ,@sequential-inits
  837.                  ,@body))
  838.              ,@fixed-args)
  839.                tail?
  840.                mv-holder))
  841.       (let ((fake-name (gensym "HAIRY-INLINE")))
  842.         (analyze-1 `(let ((,fake-name (function ,function)))
  843.              (funcall ,fake-name ,@args))
  844.                tail?
  845.                mv-holder))))))
  846.  
  847. (defun simple-keyword-arg-list (args)
  848.   (if (null args)
  849.       t
  850.       (and (keywordp (first args))
  851.        (if (null (cdr args))
  852.            (compiler-warn "Illegal keyword argument list")
  853.            t)
  854.        (simple-keyword-arg-list (cddr args)))))
  855.  
  856. (defun hairy->fixed-arg-list (info args all-var-names)
  857.   (if (and (not (null (var-info-keys info)))
  858.        (or (not (null (var-info-rest-var info)))
  859.            (not (null (var-info-restv-var info)))))
  860.       :skip-inline
  861.       (let ((sequential-init-forms nil))
  862.     (flet ((parallel-init-form (opt)
  863.          ;; If the init-form depends on previous vars in
  864.          ;; the lambda-list, then we must delay the init.
  865.          (let ((init-form (basic-optional-init-form opt))
  866.                (init-form-expr (basic-optional-init-form-expression
  867.                     opt)))
  868.            (if (or (constant-p init-form)
  869.                ;; Hack to detect sequential var ref dependecies
  870.                (and (atom init-form-expr)
  871.                 (not (member init-form-expr all-var-names)))
  872.                (and (listp init-form-expr)
  873.                 (null (intersection
  874.                        all-var-names
  875.                        (flatten init-form-expr)))))
  876.                init-form
  877.                ;; HEY! This does not obey sequential scoping
  878.                ;; rules for lambda list inits.
  879.                (progn (push `(setq ,(var-name (basic-optional-var opt))
  880.                       ,init-form-expr)
  881.                     sequential-init-forms)
  882.                   nil)))))
  883.       (values
  884.        (append (loop for r in (var-info-requireds info)
  885.              collect
  886.              (if (null args)
  887.                  (compiler-warn "Not enough required args for ~
  888.                                                 inline call")
  889.                  (pop args)))
  890.            (loop for opt in (var-info-optionals info)
  891.              appending
  892.              (cons (if (null args)
  893.                    (parallel-init-form opt)
  894.                    (pop args))
  895.                    (if (optional-supplied-var opt)
  896.                    (list (not (null args)))
  897.                    nil)))
  898.            (if (simple-keyword-arg-list args)
  899.                (loop for key in (var-info-keys info)
  900.                  appending
  901.                  (let ((l (member
  902.                        (constant-data (key-name key))
  903.                        args)))
  904.                    (cons (if (null l)
  905.                      (parallel-init-form key)
  906.                      (second l))
  907.                      (if (key-supplied-var key)
  908.                      (list (not (null l)))
  909.                      nil))))
  910.                (return-from hairy->fixed-arg-list :skip-inline))
  911.            (if (null (var-info-rest-var info))
  912.                nil
  913.                `(list ,@args))
  914.            (if (null (var-info-restv-var info))
  915.                nil
  916.                `(vector ,@args)))
  917.        (nreverse sequential-init-forms))))))
  918.  
  919. (defun var-lookup (name list)
  920.   (loop with through-proc? = nil
  921.     for x being the elements of list
  922.     when (and (proc-p x) (null through-proc?)) ; keep first proc
  923.     do (setf through-proc? x)
  924.     when (and (var-p x) (eq (var-name x) name))
  925.     do (return (values x through-proc?))))
  926.  
  927. (defun cp-lookup (name list)
  928.   (loop with through-proc? = nil
  929.     for x being the elements of list
  930.     when (and (proc-p x) (null through-proc?)) ; keep first proc
  931.     do (setf through-proc? x)
  932.     when (dynamic-control-point-p x)
  933.     collect x into cps
  934.     when (and (control-point-p x)
  935.           (eq (control-point-name x) name))
  936.     do (return (values x through-proc? unwind-count cps))
  937.     when (or (member x '(:UW-PROTECT :UW-SPEC-BIND))
  938.          (dynamic-control-point-p x))
  939.     count x into unwind-count))
  940.  
  941. (defun lookup-block (name)
  942.   (cp-lookup name (lex-env-blocks *env*)))
  943.  
  944. (defun lookup-tag (name)
  945.   (cp-lookup name (lex-env-tags *env*)))
  946.  
  947. (defun lookup-function (name)
  948.   (var-lookup name (lex-env-functions *env*)))
  949.  
  950. (defun lookup-variable (name)
  951.   (var-lookup name (lex-env-variables *env*)))
  952.  
  953. (defun new-label ()
  954.   (genstring "L"))
  955.  
  956. (defun current-proc ()
  957.   (first *proc-chain*))
  958.  
  959. (defun top-level-proc ()
  960.   (first (last *proc-chain*)))
  961.  
  962. ;;; MIPS CC has ridiculous type coercion rules regarding
  963. ;;; volatile, so I don't think we can use it. However, I 
  964. ;;; don't think we need it since longjmp restores regs.
  965. (defun declare-vars-volatile ()
  966.   ;; Used to be "volatile "
  967.   (setf (proc-volatile (current-proc)) ""))
  968.  
  969. (defun update-var-extent (var through-proc?)
  970.   (when through-proc?
  971.     (push var (inner-proc-oe-refs through-proc?))
  972.     (loop for p in *proc-chain*
  973.       do (etypecase p
  974.            (top-level-proc
  975.         (pushnew var (top-level-proc-oe-vars p)))
  976.            (inner-proc
  977.         (setf (inner-proc-pass-on-oe? p) t))))
  978.     (setf (var-extent var) :indefinite)))
  979.  
  980.  
  981. (defun analyze-lambda-list (lambda-list &optional inline-function?)
  982.   (letf ((lex-env-variables *env*) (lex-env-variables *env*)) 
  983.     (key-list-iterate munch
  984.     (next lambda-list
  985.           (let* ((req (nreverse requireds))
  986.              (o (nreverse optionals))
  987.              (k (nreverse keys))
  988.              (r (if (and (null rest) (not inline-function?))
  989.                 (if (null keys)
  990.                 nil
  991.                 (let ((v (new-var (gensym "KEYS") t)))
  992.                   (setf (var-dynamic-extent? v) t)
  993.                   v))
  994.                 (car rest)))
  995.              (rv (car restv))
  996.              (hairy? (or o k r rv)))
  997.         (when (and hairy?
  998.                (not (c-compiler-ansi-var-args?
  999.                  (machine-c-compiler *target-machine*))))
  1000.           (loop for r in req do
  1001.             (push r (proc-vars-to-declare
  1002.                  (current-proc)))))
  1003.         (unless (or (null r) (null rv))
  1004.           (compiler-warn
  1005.            "You cannot use &REST and &RESTV at the same time"))
  1006.         (make-var-info
  1007.          :requireds req :optionals o :keys k :rest-var r :restv-var rv
  1008.          :auxes (nreverse auxes)
  1009.          :hairy? hairy?
  1010.          :all-vars (append
  1011.                 req
  1012.                 (mapcan #'list-basic-optional-vars o)
  1013.                 (mapcan #'list-basic-optional-vars k)
  1014.                 rest
  1015.                 restv)
  1016.          :allow-other-keys? allow-other-keys?)))
  1017.     ((requireds nil) (optionals nil) (rest nil)
  1018.      (restv nil) (keys nil) (auxes nil) (allow-other-keys? nil)
  1019.      (current '&required)
  1020.      (order '(&optional &rest &restv &key &allow-other-keys &aux)))
  1021.       (let ((new-order (member next order :test #'eq)))
  1022.     (if (null new-order)
  1023.         (if (member next lambda-list-keywords)
  1024.         (error "Keyword ~A is not permitted, out of order, ~
  1025.                         or repeated in the lambda list ~A"
  1026.                next lambda-list)
  1027.         (ecase current
  1028.           (&required (munch :requireds (cons (create-required-var next)
  1029.                              requireds)))
  1030.           (&optional (munch :optionals (cons (create-optional next)
  1031.                              optionals)))
  1032.           (&rest (if (null (cdr rest))
  1033.                  (munch :rest (cons (create-rest-var next)
  1034.                         rest))
  1035.                  (error "Too many &REST args ~A" rest)))
  1036.           (&restv (if (null (cdr restv))
  1037.                   (munch :restv (cons (create-rest-var next)
  1038.                           restv))
  1039.                   (error "Too many &RESTV args ~A" rest)))
  1040.           (&key (munch :keys (cons (create-key next) keys)))
  1041.           (&aux (munch :auxes (cons (create-aux next) auxes)))))
  1042.         (munch :current (car new-order)
  1043.            :order (cdr new-order)
  1044.            :allow-other-keys? (or allow-other-keys?
  1045.                       (eq (car new-order)
  1046.                           '&allow-other-keys))))))))
  1047.  
  1048. (defun create-required-var (name)
  1049.   (if (symbolp name)
  1050.       (let ((v (new-var name nil)))
  1051.     (push v (lex-env-variables *env*))
  1052.     v)
  1053.       (error "~A is not legal as the name of a required variable" name)))
  1054.  
  1055. (defun create-rest-var (name)
  1056.   (let ((v (new-var name t)))
  1057.     (push v (lex-env-variables *env*))
  1058.     v))
  1059.  
  1060. (defun create-optional (optional)
  1061.   (let* ((v (new-var (if (atom optional) optional (car optional))
  1062.              t))
  1063.      (o (fill-basic-optional-slots optional (make-optional :var v))))
  1064.     (push-basic-opt-vars-onto-env o)
  1065.     o))
  1066.  
  1067. (defun create-key (key)
  1068.   (flet ((make-name (key)
  1069.        (analyze-1 (intern (symbol-name key)
  1070.                   (find-package "KEYWORD"))
  1071.               nil
  1072.               nil)))
  1073.     (let ((k (cond ((atom key)
  1074.             (make-key :var (new-var key t)
  1075.                   :name (make-name key)))
  1076.            ((atom (car key))
  1077.             (fill-basic-optional-slots
  1078.              key
  1079.              (make-key :var (new-var (car key) t)
  1080.                    :name (make-name (car key)))))
  1081.            (t (fill-basic-optional-slots
  1082.                key
  1083.                (make-key :var (new-var (second (car key)) t)
  1084.                  :name (make-name (first (car key)))))))))
  1085.       (push-basic-opt-vars-onto-env k)
  1086.       k)))
  1087.  
  1088. (defun push-basic-opt-vars-onto-env (o)
  1089.   (push (basic-optional-var o) (lex-env-variables *env*))
  1090.   (let ((supp (basic-optional-supplied-var o)))
  1091.     (unless (null supp) (push supp (lex-env-variables *env*)))))
  1092.  
  1093. (defun list-basic-optional-vars (o)
  1094.   (let ((req (basic-optional-var o))
  1095.     (supp (basic-optional-supplied-var o)))
  1096.     (cons req  (if (null supp) nil (list supp)))))
  1097.  
  1098. (defun fill-basic-optional-slots (list struct)
  1099.   (unless (atom list)
  1100.     (setf (basic-optional-init-form-expression struct)
  1101.       (second list))
  1102.     (setf (basic-optional-init-form struct)
  1103.       (analyze-1 (second list) nil nil))
  1104.     (setf (basic-optional-supplied-var struct)
  1105.       (if (null (third list))
  1106.           nil
  1107.           (new-var (third list) t))))
  1108.   struct)
  1109.  
  1110. (defun create-aux (aux)
  1111.   (if (atom aux) `(,aux nil) aux))
  1112.  
  1113. (defun parse-decls (decls)
  1114.   (key-list-iterate parse
  1115.       (spec decls (make-decls :specials specials
  1116.                   :types types
  1117.                   :ftypes ftypes    
  1118.                   :inlines inlines
  1119.                   :notinlines notinlines
  1120.                   :ignores ignores
  1121.                   :dynamic-extents dynamic-extents
  1122.                   :optimizes optimizes))
  1123.       ((specials nil)
  1124.        (types nil)
  1125.        (ftypes nil)
  1126.        (inlines nil)
  1127.        (notinlines nil)
  1128.        (ignores nil)
  1129.        (dynamic-extents nil)
  1130.        (optimizes nil))
  1131.     (case (car spec)
  1132.       (special (parse :specials (append (cdr spec) specials)))
  1133.       (type (parse :types (add-type-decls (second spec) (cddr spec) types)))
  1134.       (ftype (parse :ftypes (add-type-decls (second spec) (cddr spec) ftypes)))
  1135.       (function (parse :ftypes (add-type-decls `(function ,@(cddr spec))
  1136.                            (list (second spec))
  1137.                            ftypes)))
  1138.       (inline (parse :inlines (append (cdr spec) inlines)))
  1139.       (notinline (parse :notinlines (append (cdr spec) notinlines)))
  1140.       ;; HEY! make ignoreable work correctly.
  1141.       ((ignore ignoreable) (parse :ignores (append (cdr spec) ignores)))
  1142.       (dynamic-extent (parse :dynamic-extents (append (cdr spec)
  1143.                               dynamic-extents)))
  1144.       (optimize (parse :optimizes (append (cdr optimizes) ignores)))
  1145.       (t (cond ((legal-shorthand-type-decl-p (car spec))
  1146.         (parse :types (add-type-decls (car spec) (cdr spec) types)))
  1147.            ((ok-foreign-declaration-p (car spec))
  1148.         (parse))
  1149.            (t (progn (warn "Ignoring unknown declaration ~A"
  1150.                    spec)
  1151.              (parse))))))))
  1152.  
  1153. (defun new-decl-env (decls)
  1154.   (if (null decls)
  1155.       (lex-env-decls *env*)
  1156.       (cons (parse-decls decls) (lex-env-decls *env*))))
  1157.  
  1158. (defun add-type-decls (type-spec vars existing-type-decls)
  1159.   (let ((expanded-type-spec (type-macroexpand type-spec)))
  1160.     (append (mapcar #'(lambda (var)
  1161.             (cons var expanded-type-spec))
  1162.             vars)
  1163.         existing-type-decls)))
  1164.  
  1165. (defun legal-shorthand-type-decl-p (type-spec)
  1166.   (member (if (atom type-spec)
  1167.           type-spec
  1168.           (car type-spec))
  1169.       *standard-type-specifier-symbols*))
  1170.  
  1171. (defun lookup-special-decl (var decls-list)
  1172.   (dolist (decls decls-list (proclaimed-special? var))
  1173.     (when (member var (decls-specials decls))
  1174.       (return :special))))
  1175.  
  1176. (defun lookup-type-decl (var)
  1177.   (dolist (decls (lex-env-decls *env*) t)
  1178.     (let ((entry (assoc var (decls-types decls))))
  1179.       (unless (null entry)
  1180.     (return (cdr entry))))))
  1181.  
  1182. (defun lookup-dynamic-extent-decl (var)
  1183.   (dolist (decls (lex-env-decls *env*))
  1184.     (when (member var (decls-dynamic-extents decls))
  1185.       (return t))))
  1186.  
  1187. (defun lookup-ignore-decl (var)
  1188.   (dolist (decls (lex-env-decls *env*))
  1189.     (when (member var (decls-ignores decls))
  1190.       (return t))))
  1191.  
  1192. ;;; HEY! This should only return true if we find an inline decl
  1193. ;;; AND we actually have lambda-expr info availabe for the function!!!
  1194. ;;; Don't use this until we fix it.
  1195. (defun lookup-inline-decl (func decls-list)
  1196.   (dolist (decls decls-list)
  1197.     (when (member func (decls-inlines decls))
  1198.       (return t))))
  1199.  
  1200. (defun lookup-notinline-decl (func decls-list)
  1201.   (dolist (decls decls-list)
  1202.     (when (member func (decls-notinlines decls))
  1203.       (return t))))
  1204.  
  1205. (defun inline-function? (func function-info)
  1206.   (let ((decls-list (lex-env-decls *env*)))
  1207.     (and (not (lookup-notinline-decl func decls-list))
  1208.      (or ;; Dont use this until fixed: (lookup-inline-decl func decls-list)
  1209.          (proc-info-inline? function-info)))))
  1210.  
  1211. (defun ok-foreign-declaration-p (decl)
  1212.   (member decl *ok-foreign-declarations*))
  1213.  
  1214. (defun analyze-the (form tail? mv-holder)
  1215.   (destructuring-bind (ignore type body) form
  1216.     (declare (ignore ignore))
  1217.     (let ((tree (analyze-1 body tail? mv-holder)))
  1218.       (setf (code-out-type tree) type)
  1219.       tree)))
  1220.  
  1221. (defun new-var (name declare?)
  1222.   (let ((v (make-variable-var
  1223.         :name name
  1224.         :c-name (lisp->c-variable-name name (new-name-id))
  1225.         :definite-type (lookup-type-decl name)
  1226.         :declared-ok-to-ignore? (lookup-ignore-decl name)
  1227.         :num-refs 0
  1228.         :num-defs 0
  1229.         :extent :dynamic
  1230.         :dynamic-extent? (lookup-dynamic-extent-decl name)
  1231.         :innermost-proc (current-proc))))
  1232.     (when declare?
  1233.       (push v (proc-vars-to-declare (current-proc))))
  1234.     v))
  1235.  
  1236. (defun new-fvar (name)
  1237.   (let ((v (make-function-var
  1238.         :name name
  1239.         :c-name (lisp->c-function-name name (new-name-id))
  1240.         :num-refs 0
  1241.         :num-defs 0
  1242.         :extent :dynamic
  1243.         :dynamic-extent? (lookup-dynamic-extent-decl name)
  1244.         :innermost-proc (current-proc))))
  1245.     (push v (proc-vars-to-declare (current-proc)))
  1246.     v))
  1247.  
  1248. (defun hairy-lambda-list? (lambda-list)
  1249.   (dolist (x lambda-list)
  1250.     (when (member x lambda-list-keywords :test #'eq)
  1251.       (return t))))
  1252.  
  1253. (defun proc-required-vars (p)
  1254.   (var-info-requireds (proc-var-info p)))
  1255.  
  1256. (defun collect-specials (var-list)
  1257.   (loop for var in var-list
  1258.     for spec? = (special-var-p (var-name var))
  1259.     when (eq spec? :special)
  1260.     collect var
  1261.     when (eq spec? :constant)
  1262.     do (compiler-warn "~A has been declared constant but you ~
  1263.                             are using it as a variable" (var-name var))))
  1264.  
  1265. (defun anonymous-function-expr? (expr)
  1266.   (and (listp expr) (listp (second expr))))
  1267.  
  1268. (defun lambda-expr? (l)
  1269.   (and (eq (first l) 'lambda)
  1270.        (listp (second l))))
  1271.  
  1272. (defun new-var-ref (var through-proc?)
  1273.   (incf (var-num-refs var))
  1274.   (update-var-extent var through-proc?)
  1275.   (make-var-ref :var var
  1276.         :out-type (var-definite-type var)
  1277.         :innermost-proc (current-proc)))
  1278.  
  1279. (defun new-name-id ()
  1280.   (prog1 *name-id-counter*
  1281.     (incf *name-id-counter*)))
  1282.  
  1283. (defun c-type->lisp-type (c-type)
  1284.   (case c-type
  1285.     (int 'fixnum)
  1286.     (double 'float)
  1287.     (char 'character)
  1288.     (if-test 't)
  1289.     (t c-type)))
  1290.  
  1291. (defun flatten (l)
  1292.   (if (null l)
  1293.       nil
  1294.       (if (atom (car l))
  1295.       (cons (car l) (flatten (cdr l)))
  1296.       (append (flatten (car l)) (flatten (cdr l))))))    
  1297.  
  1298. (defun dynamic-control-point-p (x)
  1299.   (typep x '(or dynamic-scope-control-point dynamic-tag-control-point)))
  1300.  
  1301. (defun unique-control-point-tag (name)
  1302.   (analyze-1 `(quote ,(gentemp (symbol-name name))) nil nil))
  1303.  
  1304. (defun make-progn-if-needed (body)
  1305.   (cond ((atom body) body)
  1306.     ((null (cdr body)) (car body))
  1307.     (t (make-progn :body body))))
  1308.  
  1309.  
  1310.